$NOFLOATCALLS
$STORAGE: 2
C PROGRAM TO READ/WRITE DIF FILES FROM .PCC FILES
	CHARACTER*1 FORM,FVLD
	INTEGER*4 VNLT
	CHARACTER*1 LET1,LET2,FORM2(128),NMSH(80)
	CHARACTER*1 DIFHDR(10)
	COMMON/NMSH/NMSH
	INTEGER*2 IOLVL
	DIMENSION FORM(128),FVLD(1,1)
	CHARACTER*1 FVWRK,FVWRK2
C FVLD FLAG 0 = NO FORMULA, -1= DISPLAY FORMULA ITSELF, NOT VALUE
C 1=VALID ACTIVE FORMULA THERE TO EVALUATE. INITIALLY ALL 0'S
C SO INITIALLY IGNORE.
C FVLD=2 = CONST NUMERIC ONLY, COMPUTED. =3, CONST, NEEDS CALC.
C
C ROUTINE IN2AS COMPUTES ASCII CHARACTER NAMES OF SUBSCRIPTS IN1,IN2
C SO DISPLAY CAN HAVE THEM. IT MUST BE THE INVERSE OF VARSCN.
	CHARACTER*1 LETA
	CHARACTER*127 CFORM,CFORM2
	EQUIVALENCE(CFORM,FORM(1))
	EQUIVALENCE(CFORM2,FORM2(1))
	integer*2 nrows,ncols
	character*9 DFMT
C ENCODE ICREF, IRREF AND CWIDS PAST TITLE IN FIRST LINE
C (THAT WAY, NOTHING BREAKS IN OTHER PGMS THAT USE THIS)
C
C PUT NUMBERS OUT TO FILE
C USES RELATIVE FORMS TO CURRENT POS.
C PD = PUT OURT DISPLAY SHEET. PP = PUT OUT PHYSICAL SHEET.
C ONLY WRITES PHYSICALLY PRESENT DATA.
C P/D RRR,CCC,FORMULA,VALID,FORMAT
C N IN 3RD CHR (PPN/PDN) SAVES NUMBERS, ELSE FORMULAS.
	IOLVL=5
	OPEN(UNIT=5,FILE='CON:',STATUS='OLD')
	OPEN(UNIT=6,FILE='CON:',STATUS='NEW')
	WRITE(6,101)
101	FORMAT('$Read DIF file to PCC or Write DIF file from'
     1  ,' PCC [R/W]:')
	READ(5,7953)FORM2
	INDIF=1
	IF(FORM2(1).EQ.'R'.or.form2(1).eq.'r')INDIF=0
	WRITE(6,102)
102	FORMAT('$ Enter DIF filename>')
	III=IOLVL
	READ(III,7953,END=510,ERR=510)FORM2
7953	FORMAT(128A1)
	DO 6940 II=1,128
	ILN=129-II
	IF(ICHAR(FORM2(ILN)).GT.32)GOTO 6941
	FORM2(ILN)=CHAR(0)
6940	CONTINUE
6941	CONTINUE
C ILN IS LENGTH OFLINE NOW.
	ILN=MIN0(ILN,127)
	FORM2(ILN+1)=CHAR(0)
	IF(INDIF.EQ.0)CALL RASSIG(3,FORM2)
	IF(INDIF.NE.0)CALL WASSIG(4,FORM2)
C LUN 3 IS INPUT, LUN 4 IS OUTPUT
C NOW GET PCC FILENAME
	WRITE(6,103)
103	FORMAT('$ Enter PCC filename>')
	READ(III,7953,END=510,ERR=510)FORM2
	DO 6340 II=1,128
	ILN=129-II
	IF(ICHAR(FORM2(ILN)).GT.32)GOTO 6341
	FORM2(ILN)=CHAR(0)
6340	CONTINUE
6341	CONTINUE
C ILN IS LENGTH OFLINE NOW.
	ILN=MIN0(ILN,127)
	FORM2(ILN+1)=CHAR(0)
	IF(INDIF.ne.0)CALL RASSIG(3,FORM2)
	IF(INDIF.eq.0)CALL WASSIG(4,FORM2)
c Now both files are opened and all set, and INDIF flag tells
c whether the DIF file is the input or the output (0=input)
c
c Now since DIF files don't have a valid format, if we're reading
c DIF and writing PCC files, ask for a display format.
	IF (Indif.ne.0)goto 105
	Write(6,106)
106	Format('$ Enter display format, no ().>')
	Read(5,107)DFMT
c may need to change format...
107	Format(A9)
	GOTO 1000
105	Continue
	WRITE(6,900)
900	FORMAT('$ Emit Values or Formulas [V/F]:')
	Read(5,7953)let2
C UPCASE V REPLY SINCE WE TEST EITHER 'V' OR NOT 'V' ONLY.
	IF(LET2.EQ.'v')LET2='V'
c LET2 tells us whether to emit Values or "Labels" in the DIF
c file...
C AT 1000 HANDLE READING DIF FILES TO PCC FILES
C NEXT HANDLE READING PCC FILES TO DIF FILES.
C
C  PCC IN, DIF OUT
C
C FIRST PASS: READ IN PCC FILE TO SEE HOW MANY ROWS AND COLS
C ARE THERE SINCE THAT'S NEEDED FOR DIF.
	NCOLS=0
	NROWS=0
	READ(3,6951,END=9990,ERR=9990)NMSH,FORM
6951	FORMAT(100A1,100A1,100A1)
1107	CONTINUE
C7955	FORMAT('P',I5,',',I5,',',128A1)
C READ THE DATA AND KEEP MAXIMA FOR ROW, COL UNTIL EOF
C	READ (3,108,END=109,ERR=109)LETR,ICOL,IROW,FORM
	READ (3,108,END=109)LETR,ICOL,IROW,FORM
	NCOL=ICOL
	NROW=IROW
108	FORMAT(1A1,I5,1X,I5,1X,128A1)
7956	FORMAT(I3,1X,9A1,1X,I5)
C	READ(3,7956,END=109,ERR=109)IVLD,(FORM2(IV),IV=120,
C     1  128),ITYPE
	READ(3,7956,END=109)IVLD,(FORM2(IV),IV=120,
     1  128),ITYPE
	IF(LETR.EQ.'M')GOTO 109
C DON'T BOTHER WITH MAPPING RECORDS WHICH ARE AT END...
	IF(LETR.NE.'P')GOTO 1107
	IF(NCOL.GT.NCOLS)NCOLS=NCOL
	IF(NROW.GT.NROWS)NROWS=NROW
	GOTO 1107
109	CONTINUE
C NOW HAVE DIMENSIONS...
	REWIND 3
	WRITE(6,5000)NCOLS,NROWS
5000	FORMAT(' NUMBER OF COLS FOUND=',I6,';NUMBER OF ROWS='
     1  ,I6)
	IF(NCOLS.LE.0.OR.NCOLS.GT.999)STOP 'COLS ERR'
	IF(NROWS.LE.0.OR.NROWS.GT.999)STOP 'ROWS ERR'
	READ(3,6951,END=9990,ERR=9990)NMSH,FORM
C NOW EMIT TABLE RECORD USING TITLE OF SHEET AS STRING
	WRITE(4,110)
110	FORMAT('TABLE',/,'0,1')
	WRITE(4,111)(NMSH(IV),IV=1,75)
111	FORMAT('"',75A1,'"')
C VECTORS IS DIF SLANG FOR COLUMNS. EMIT NUMBER OF VECTORS.
	WRITE(4,112)NCOLS
112	FORMAT('VECTORS',/,'0,',I3,/,'""')
C NEXT WRITE TUPLES RECORD WHICH IS BASICALLY NUMBER OF ROWS
	WRITE(4,113)NROWS
113	FORMAT('TUPLES',/,'0,',I3,/,'""')
	WRITE(4,114)
114	FORMAT('DATA',/,'0,0',/,'""')
C WE ASKED EARLIER FOR LET2 TO BE V FOR VALUES OR F FOR FORMULAS
C TO TELL WHICH TO EMIT.
C NOW GO THROUGH AND HANDLE THE STUFF...
	ICOLI=0
	IROWI=1
	ICOLS=NCOLS
	IROWX=1
	ICOLX=1
	IROWS=NROWS
	WRITE(4,121)
121	FORMAT('-1,0',/,'BOT')
118	CONTINUE
	READ (3,108,END=119,ERR=119)LETR,ICOL,IROW,FORM
	NCOL=ICOL
	NROW=IROW
	READ(3,7956,END=119,ERR=119)IVLD,(FORM2(IV),IV=120,
     1  128),ITYPE
C ONLY ACCEPT P OR p TYPE RECORDS (ONLY ONE, DEPENDING ON LET1)
	IF(LETR.NE.'P'.AND.LET2.NE.'V')GOTO 118
	IF(LETR.NE.'p'.AND.LET2.EQ.'V')GOTO 118
C HERE WE KNOW WE'RE LEGAL
C SINCE THE NEW VERSIONS OF ANALYTICALC GENERATE DATA ACROSS COLUMNS
C FIRST (I.E., ALONG TUPLES), JUST KEEP TRACK OF LAST ONE
C READ AND FILL IN NULLS IF WE MUST.
C	ICOLX=ICOLX+1
C	IF(ICOLX.LE.ICOLS)GOTO 120
C	ICOLX=1
C	IROWX=IROWX+1
C120	CONTINUE
C ICOLX AND IROWX ARE NEXT COL AND ROW EXPECTED IF WE READ A TOTALLY
C FILLED TABLE AREA'S SAVED FILE.
122	CONTINUE
	IF(ICOL.LE.ICOLX.AND.IROW.LE.IROWX)GOTO 123
C NEED TO FILL IN EMPTIES...
	WRITE(4,125)
125	FORMAT('0,0',/,'NA')
	ICOLX=ICOLX+1
	IF(ICOLX.LE.ICOLS)GOTO 124
	ICOLX=1
	IROWX=IROWX+1
C WRITE ANOTHER BOT RECORD AS NEEDED HERE (IN CASE WHOLE ROW IS
C EMPTY)
C ONLY EMIT RECORD IF WE DIDN'T JUST FINISH THE LAST ROW.
	IF(IROWX.LE.IROWS)WRITE(4,121)
124	CONTINUE
	GOTO 122
123	CONTINUE
C OK, NOW HAVE THIS FILLED IN...
	IF(LET2.NE.'V')GOTO 128
C MUST ENSURE THAT THE EXPONENT IS NN.NNNEXX RATHER THAN NN.NNNNDXX
C I.E., D EXPONENTS AREN'T UNDERSTOOD. THEREFORE WRITE OUT E INSTEAD
C OF D.
	DO 200 IV=1,50
	IF(FORM(IV).EQ.'D')FORM(IV)='E'
200	CONTINUE
128	CONTINUE
	IF(LET2.EQ.'V')WRITE(4,126)(FORM(IV),IV=1,50)
126	FORMAT('0,',50A1,/,'V')
	IF(LET2.NE.'V')WRITE(4,127)(FORM(IV),IV=1,109)
127	FORMAT('1,0',/,109A1)
C GO BACK AND READ SOME MORE NOW
	ICOLI=ICOL
	IROWI=IROW
	ICOLI=ICOLI+1
	IF(ICOLI.LE.ICOLS)GOTO 2120
	ICOLI=1
	IROWI=IROWI+1
	WRITE(4,121)
2120	CONTINUE
	ICOLX=ICOLI
	IROWX=IROWI
	GOTO 118
C
119	CONTINUE
C ALL DONE, SO MARK END DATA AND GO HOME.
C MUST BE SURE WE FILL OUT THE LAST TUPLE SO WRITE 'NA' RECORDS
C IF IT'S NEEDED.
	IF(IROWX.GT.IROWS.OR.ICOLX.GT.ICOLS)GOTO 9191
	DO 9192 N=ICOLX,ICOLS
	WRITE(4,125)
C WRITE 'NA' RECORDS IN LOOP
9192	CONTINUE
9191	CONTINUE
	WRITE(4,129)
129	FORMAT('-1,0'/,'EOD')
	CLOSE(UNIT=4)
	CLOSE(UNIT=3)
	GOTO 9990
1000	CONTINUE
C
C DIF IN, PCC OUT
C
C ASSUME DIF FILE STARTS WITH TABLE, VECTORS, TUPLES RECORDS
	READ(3,1001)DIFHDR
1001	FORMAT(10A1)
	READ(3,1002)N1,N2
1002	FORMAT(I1,1X,I5)
	READ(3,7953)FORM2
C FORM2 GETS STRING OUT OF DIF RECORD
C GET RID OF " CHARACTERS IN TITLE
3211	CONTINUE
	N1=INDEX(CFORM2,'"')
	IF(N1.LE.0.OR.N1.GT.127)GOTO 3212
C REPLACE " CHARACTERS WITH SPACES.
	FORM2(N1)=' '
	GOTO 3211
3212	CONTINUE
	IF(DIFHDR(1).EQ.'T'.AND.DIFHDR(2).EQ.'A'.AND.DIFHDR(3)
     1  .EQ.'B')WRITE(4,1003)(FORM2(IV),IV=2,81)
C 2,81 LIMITS TO SKIP WRITING INITIAL " CHARACTER TO PCC FILE.
C (OR SPACE IT GOT CHANGED TO)
1003	FORMAT(80A1)
	IF(DIFHDR(1).EQ.'T'.AND.DIFHDR(2).EQ.'U'.AND.
     1  DIFHDR(3).EQ.'P')NROWS=N2
	IF(DIFHDR(1).EQ.'V'.AND.DIFHDR(2).EQ.'E'.AND.
     1  DIFHDR(3).EQ.'C')NCOLS=N2
	IF(DIFHDR(1).NE.'D'.OR.DIFHDR(2).NE.'A')GOTO 1000
C FALL THROUGH AFTER READING DATA RECORD
C HOPEFULLY WE NOW HAVE NUMBER OF ROWS AND COLUMNS EXPECTED
C ALL STORED IN NROWS AND NCOLS.
	IROW=0
	ICOL=0
1010	CONTINUE
	READ(3,7953,END=9900)FORM
	N1=0
	IX=INDEX(CFORM,',')-1
	IF(IX.LE.0)GOTO 8092
	READ(CFORM,8090)N1
8090	FORMAT(I3)
	DO 8091 N=1,123
8091	FORM(N)=FORM(N+IX+1)
8092	CONTINUE
C READ NUMBER VALUE IN A STRING SO WE CAN DECODE IT AS
C NEEDED.
	READ(3,7961,END=9900)FORM2
7961	FORMAT(100A1,100A1)
C READ A RECORD
C N1 = -1 FLAGS SPECIAL RECORDS
	IF(N1.GE.0)GOTO 1020
	IF(FORM2(1).EQ.'B'.AND.FORM2(2).EQ.'O'
     1  .AND.FORM2(3).EQ.'T')GOTO 1019
	IF(FORM2(1).EQ.'E'.AND.FORM2(2).EQ.'O')GOTO 9900
	GOTO 1010
1019	CONTINUE
C AT START OF TUPLE RESET COL TO 1 AND ROW BUMPS...
	IROW=IROW+1
	ICOL=0
	GOTO 1010
C SKIP OVER NONDATA RECORDS
1020	CONTINUE
C NOW HAVE TO EMIT A DATA RECORD.
	IVLD=-1
	IF(N1.EQ.0)IVLD=1
	ICOL=ICOL+1
	IF(IVLD.EQ.1.AND.FORM2(1).EQ.'N'.AND.FORM2(2).EQ.
     1  'A') GOTO 1010
C SKIP 'NA' INVALID NUMBERS AND DON'T BOTHER WRITING THEM.
	IF(IVLD.EQ.1)WRITE(4,1030)ICOL,IROW,(FORM(IV),IV=1,110)
	IF(IVLD.LT.1)WRITE(4,1030)ICOL,IROW,(FORM2(IV),IV=1,110)
1030	FORMAT('P',I5,',',I5,',',128A1)
	ITYPE=2
C FIGURE OUT TYPE BASED ON PRESENCE OR ABSENCE OF DOT.
	IF(IVLD.GT.1.AND.INDEX(CFORM,'.').EQ.0)ITYPE=4
	WRITE(4,1031)IVLD,DFMT,ITYPE
1031	FORMAT(I3,',',A9,',',I5)
	GOTO 1010
9900	CONTINUE
	CLOSE(UNIT=4)
	CLOSE(UNIT=3)
510	CONTINUE
9990	stop
	END
$NOFLOATCALLS
$STORAGE: 2
      INTEGER FUNCTION INDEX ( STR, C )
C
      CHARACTER * 1 C, STR ( 1 )
C
C LIMIT RANGE OF SEARCH TO 256 BYTES. THIS IS ARBITRARY BUT I DOUBT
C ANALYTICALC WILL EVER DEAL IN LONGER STRINGS THAN THIS AND
C SEARCHES ALL OVER THE CREATION ARE TO BE AVOIDED.
	I3B=0
      DO 20019  I = 1, 256
      IF (STR(I).NE.0) GOTO 20021
C RETURN INDEX AS EITHER THE LOCATION OF THE CHARACTER OR 0
      INDEX=0
      RETURN
20021 CONTINUE
	IF(ICHAR(STR(I)).EQ.255)I3B=3
	IF(I3B.LE.0)GOTO 2000
C SKIP ENCODED VARIABLES
	I3B=I3B-1
	GOTO 20019
2000	CONTINUE
      IF (.NOT.( STR ( I ) .EQ. C )) GOTO 20023
	ix=i
	if(i.gt.250)ix=0
      INDEX = ( IX )
      RETURN
20023 CONTINUE
20022 CONTINUE
C
20019 CONTINUE
20020 CONTINUE
      END
$NOFLOATCALLS
$STORAGE: 2
	SUBROUTINE RASSIG(IUNIT,NAME)
C
C
	CHARACTER*1 NAME(50)
	INTEGER*2 IUNIT
C &&&& MS FTN 3.2
	LOGICAL LEXIST
C &&&&
	CHARACTER*20 WK
	CHARACTER*1 WK1(20)
	EQUIVALENCE(WK,WK1(1))
C JUST TRY AND NULL FILL A NAME TO USE.
	DO 1 N=1,20
	WK1(N)=' '
1	CONTINUE
	DO 2 N=1,20
	II=ICHAR(NAME(N))
	IF(II.LT.32)GOTO 3
	WK1(N)=CHAR(II)
C1	CONTINUE
2	CONTINUE
3	CONTINUE
C CHECK FOR NONEXISTENT FILE FIRST AND CREATE AN EMPTY ONE
C IF POSSIBLE, THEN CLOSE AND OPEN FOR READ. THIS MAY
C AVOID CRASHES IF THE FILE ISN'T THERE...
C MSDOS FORTRAN 3.2 AND LATER FEATURE...
C &&&&
C
C	INQUIRE(FILE=WK,EXIST=LEXIST,ERR=77)
C
	INQUIRE(FILE=WK,EXIST=LEXIST)
	IF(LEXIST)GOTO 100
C FILE DOES NOT EXIST, SO CREATE IT HERE.
C IF CREATE FAILS WE LOSE TOO...
	write(6,7766)
7766	format(' No such file...')
100	CONTINUE
C &&&&
C IF JUST CALL ASSIGN, ASSUME FOR READ.
	OPEN(IUNIT,FILE=WK,STATUS='OLD',ACCESS='SEQUENTIAL',
     1  FORM='FORMATTED')
77	CONTINUE
C ON ERRORS IN INQUIRE, ASSUME AN ILLEGAL DEVICE OR SOMETHING
C ELSE WEIRD AND JUST DON'T BOTHER WITH THE OPEN.
	RETURN
	END
$NOFLOATCALLS
$STORAGE: 2
	SUBROUTINE WASSIG(IUNIT,NAME)
C
C
	CHARACTER*1 NAME(50)
	INTEGER*2 IUNIT
	CHARACTER*20 WK
	CHARACTER*1 WK1(20)
	EQUIVALENCE(WK,WK1(1))
C JUST TRY AND NULL FILL A NAME TO USE.
	DO 1 N=1,20
	WK1(N)=' '
1	CONTINUE
	DO 2 N=1,20
	II=ICHAR(NAME(N))
	IF(II.LT.32)GOTO 3
	WK1(N)=CHAR(II)
C1	CONTINUE
2	CONTINUE
3	OPEN(IUNIT,FILE=WK,STATUS='NEW',ACCESS='SEQUENTIAL',
     1  FORM='FORMATTED')
	RETURN
	END
